home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 22 / CU Amiga Magazine's Super CD-ROM 22 (1998)(EMAP Images)(GB)[!][issue 1998-05].iso / PowerPC / Programming / PPCsiod / sources / leval.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-09-22  |  10.3 KB  |  367 lines
  1. /* Scheme In One Define.
  2.  
  3. The garbage collector, the name and other parts of this program are
  4.  
  5.  *                     COPYRIGHT (c) 1989 BY                              *
  6.  *      PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  7.  
  8. Conversion  to  full scheme standard, characters, vectors, ports, complex &
  9. rational numbers, and other major enhancments by
  10.  
  11.  *      Scaglione Ermanno, v. Pirinoli 16 IMPERIA P.M. 18100 ITALY        * 
  12.  
  13. Permission  to use, copy, modify, distribute and sell this software and its
  14. documentation  for  any purpose and without fee is hereby granted, provided
  15. that  the  above  copyright  notice appear in all copies and that both that
  16. copyright   notice   and   this  permission  notice  appear  in  supporting
  17. documentation,  and that the name of Paradigm Associates Inc not be used in
  18. advertising or publicity pertaining to distribution of the software without
  19. specific, written prior permission.
  20.  
  21. PARADIGM  DISCLAIMS  ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
  22. ALL  IMPLIED  WARRANTIES  OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
  23. PARADIGM  BE  LIABLE  FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
  24. ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
  25. IN  AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
  26. OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  27.  
  28. */
  29.  
  30. #include <stdio.h>
  31. #include <string.h>
  32. #include <ctype.h>
  33. #include <setjmp.h>
  34. #include <signal.h>
  35. #include <math.h>
  36.  
  37. #include "siod.h"
  38.  
  39.  
  40. LISP lleval(LISP x,LISP env)
  41. {if(EQ(env,sym_user_environment)) env = NIL;
  42.  else if(NENVP(env)) env = sym_initial_environment;
  43.  return(leval(x,env));}
  44.  
  45. LISP leval(LISP x,LISP env)
  46. {LISP tmp,arg1,arg2,arg3;
  47.  loop:
  48.  switch TYPE(x)
  49.    {case tc_symbol:
  50.       tmp = envlookup(x,env);
  51.       if NULLP(tmp)
  52.         {if(EQ(VCELL(x),unbound_marker)) 
  53.            {cur_exp = x;
  54.             cur_env = env;
  55.             err("variable not bound in current environment",x,ERR_GEN);}
  56.          tmp = VCELL(x);}
  57.       else
  58.          tmp = cdr(tmp);
  59.       if(NTYPEP(tmp,tc_macro))
  60.         return(tmp);
  61.       x = apply_proc(VCELL(tmp),cons(x,NIL),env);
  62.       goto loop;
  63.     case tc_cons:
  64.       tmp = CAR(x);
  65.       switch TYPE(tmp)
  66.     {case tc_symbol:
  67.        tmp = envlookup(tmp,env);
  68.        if NULLP(tmp)
  69.              {if(EQ(VCELL(CAR(x)),unbound_marker)) 
  70.                 {cur_exp = x;
  71.                  cur_env = env;
  72.                  err("symbol not bound in current environment",CAR(x),ERR_GEN);}
  73.               tmp = VCELL(CAR(x));
  74.               break;}
  75.        tmp = cdr(tmp);
  76.        break;
  77.      case tc_cons:
  78.        tmp = leval(tmp,env);
  79.        break;}
  80.       switch TYPE(tmp)
  81.     {case tc_macro:
  82.            x = apply_proc(VCELL(tmp),cons(x,NIL),env);
  83.            goto loop;
  84.          case tc_subr_0:
  85.            cur_exp = x;
  86.            cur_env = env;
  87.            if(NNULLP(CDR(x))) 
  88.               err("procedure needs 0 parameters",x,ERR_GEN);
  89.        return(SUBRF(tmp)());
  90.      case tc_subr_1:
  91.            arg1 = CDR(x);
  92.            if(CONSP(arg1))
  93.              {if(NNULLP(CDR(arg1))) 
  94.                 {cur_exp = x;
  95.                  cur_env = env;
  96.                  err("procedure needs 1 parameters",x,ERR_GEN);}
  97.               arg1=leval(CAR(arg1),env);}
  98.            cur_exp = x;
  99.            cur_env = env;
  100.        return(SUBR1F(tmp)(arg1));
  101.      case tc_subr_2:
  102.            arg1 = CDR(x);
  103.            if(CONSP(arg1))
  104.              {arg2 = CDR(arg1);
  105.               if(CONSP(arg2))
  106.                 {if(NNULLP(CDR(arg2))) 
  107.                    {cur_exp = x;
  108.                     cur_env = env;
  109.                     err("procedure needs 2 parameters",x,ERR_GEN);}
  110.                  arg2=leval(CAR(arg2),env);}
  111.               arg1=leval(CAR(arg1),env);}
  112.            cur_exp = x;
  113.            cur_env = env;
  114.        return(SUBR2F(tmp)(arg1,arg2));
  115.      case tc_subr_3:
  116.            arg1 = CDR(x);
  117.            if(CONSP(arg1))
  118.              {arg2 = CDR(arg1);
  119.               if(CONSP(arg2))
  120.                 {arg3 = CDR(arg2);
  121.                  if(CONSP(arg3))
  122.                    {if(NNULLP(CDR(arg3))) 
  123.                       {cur_exp = x;
  124.                        cur_env = env;
  125.                        err("procedure needs 3 parameters",x,ERR_GEN);}
  126.                     arg3=leval(CAR(arg3),env);}
  127.                  arg2=leval(CAR(arg2),env);}
  128.               arg1=leval(CAR(arg1),env);}
  129.            cur_exp = x;
  130.            cur_env = env;
  131.        return(SUBR3F(tmp)(arg1,arg2,arg3));
  132.      case tc_lsubr:
  133.            cur_exp = x;
  134.            cur_env = env;
  135.            arg1 = NULLP(CDR(x)) ? NIL : leval_args(CDR(x),env);
  136.            cur_exp = x;
  137.            cur_env = env;
  138.        return(SUBR1F(tmp)(arg1));
  139.      case tc_fsubr:
  140.            cur_exp = x;
  141.            cur_env = env;
  142.        return(SUBR2F(tmp)(CDR(x),env));
  143.      case tc_msubr:
  144.            cur_exp = x;
  145.            cur_env = env;
  146.        if NULLP(MSUBRF(tmp)(&x,&env)) return(x);
  147.        goto loop;
  148.      case tc_closure:
  149.            cur_exp = x;
  150.            cur_env = env;
  151.        env = envcons(leval_args_env(CDR(x),car(CODE(tmp)),env),
  152.              DEFENV(tmp));
  153.            x = cdr(CODE(tmp));
  154.        goto loop;
  155.      case tc_fluidclosure:
  156.       {LISP fenv;
  157.            env = DEFENV(tmp);
  158.            fenv = sym_fluid_environment;
  159.            sym_fluid_environment = envcons(NIL,sym_fluid_environment);
  160.            cur_exp = x;
  161.            cur_env = env;
  162.            fluid_extend_env(leval_args_env(CDR(x),
  163.                             car(CODE(tmp)),env));
  164.            x = leval(cdr(CODE(tmp)),env);
  165.            sym_fluid_environment = fenv;
  166.        goto loop;
  167.      case tc_rec:
  168.            cur_exp = x;
  169.            cur_env = env;
  170.        env = envcons(leval_args_env(cons(tmp,CDR(x)),car(CODE(tmp)),env),
  171.              DEFENV(tmp));
  172.        x = cdr(CODE(tmp));
  173.        goto loop;}
  174.      default:
  175.            cur_exp = x;
  176.            cur_env = env;
  177.        err("attempt to call a non procedural object",tmp,ERR_GEN);}
  178.     default:
  179.       return(x);}}
  180.  
  181. LISP procp(LISP x)
  182. {
  183. switch TYPE(x)
  184.  {case tc_subr_0:
  185.   case tc_subr_1:
  186.   case tc_subr_2:
  187.   case tc_subr_3:
  188.   case tc_lsubr:
  189.   case tc_fsubr:
  190.   case tc_msubr:
  191.   case tc_closure:
  192.   case tc_fluidclosure:
  193.   case tc_rec:
  194.   return(truth);
  195.   default:
  196.   return(NIL);}}
  197.  
  198. LISP procedurep(LISP x)
  199. {
  200. switch TYPE(x)
  201.  {case tc_subr_0:
  202.   case tc_subr_1:
  203.   case tc_subr_2:
  204.   case tc_subr_3:
  205.   case tc_lsubr:
  206.   case tc_fsubr:
  207.   case tc_msubr:
  208.   return(truth);
  209.   default:
  210.   return(NIL);}}
  211.  
  212. LISP closurep(LISP x)
  213. {
  214. switch TYPE(x)
  215.  {case tc_closure:
  216.   case tc_fluidclosure:
  217.   case tc_rec:
  218.   return(truth);
  219.   default:
  220.   return(NIL);}}
  221.  
  222. LISP leval_applyif(LISP args,LISP env)
  223. {LISP tmp,proc;
  224.  tmp = leval(car(args),env);
  225.  proc = leval(car(cdr(args)),env);
  226.  if(!procp(proc))
  227.    err("apply-if",proc,ERR_SECOND | ERR_NPRO);
  228.  if NNULLP(tmp)
  229.     return(apply_proc(proc,cons(tmp,NIL),env)); 
  230.  else 
  231.     return(car(cdr(cdr(args))));}
  232.  
  233. LISP leval_apply(LISP form,LISP env)
  234. {LISP proc,args;
  235. proc = leval(car(form),env);
  236. args = leval(car(cdr(form)),env);
  237. if(!procp(proc))
  238.   err("apply",proc,ERR_FIRST | ERR_NPRO);
  239. if (NNULLP(args) && NCONSP(args))
  240.   err("apply",args,ERR_SECOND | ERR_NPAI);
  241. return(apply_proc(proc,args,env));}
  242.  
  243. LISP apply_proc(LISP proc,LISP args,LISP env)
  244. {LISP arg1,arg2,arg3;
  245. switch TYPE(proc)
  246.  {case tc_subr_0:
  247.     cur_exp = args;
  248.     cur_env = env;
  249.     if(NNULLP(args)) 
  250.        err("procedure needs 0 parameters",args,ERR_GEN);
  251.     return(SUBRF(proc)());
  252.   case tc_subr_1:
  253.     cur_exp = args;
  254.     cur_env = env;
  255.     if(NNULLP(cdr(args))) 
  256.         err("procedure needs 1 parameters",args,ERR_GEN);
  257.     arg1 = car(args);
  258.     return(SUBR1F(proc)(arg1));
  259.   case tc_subr_2:
  260.     cur_exp = args;
  261.     cur_env = env;
  262.     arg1 = car(args);
  263.     arg2 = cdr(args);
  264.     if(NNULLP(cdr(arg2))) 
  265.         err("procedure needs 2 parameters",args,ERR_GEN);
  266.     arg2 = car(args);
  267.     return(SUBR2F(proc)(arg1,arg2));
  268.   case tc_subr_3:
  269.     cur_exp = args;
  270.     cur_env = env;
  271.     arg1 = car(args);
  272.     arg2 = cdr(args);
  273.     arg3 = cdr(arg2);
  274.     if(NNULLP(cdr(arg3))) 
  275.         err("procedure needs 3 parameters",args,ERR_GEN);
  276.     arg2 = car(arg2);
  277.     arg3 = car(arg3);
  278.     return(SUBR3F(proc)(arg1,arg2,arg3));
  279.   case tc_lsubr:
  280.     cur_exp = args;
  281.     cur_env = env;
  282.     return(SUBR1F(proc)(args));
  283.   case tc_fsubr:
  284.   case tc_msubr:
  285.     cur_exp = args;
  286.     cur_env = env;
  287.     err("special forms cannot be applyed",proc,ERR_GEN);
  288.   case tc_closure:
  289.     cur_exp = args;
  290.     cur_env = env;
  291.     env = envcons(assoc_args_env(args,car(CODE(proc)),env),
  292.         DEFENV(proc));
  293.     args = cdr(CODE(proc));
  294.     return(leval(args,env));
  295.   case tc_fluidclosure:
  296.    {LISP fenv;
  297.     cur_exp = args;
  298.     cur_env = env;
  299.     env = DEFENV(proc);
  300.     fenv = sym_fluid_environment;
  301.     sym_fluid_environment = envcons(NIL,sym_fluid_environment);
  302.     fluid_extend_env(assoc_args_env(cdr(args),
  303.                               car(CODE(proc)),env));
  304.     args = leval(cdr(CODE(proc)),env);
  305.     sym_fluid_environment = fenv;
  306.     return(args);}
  307.   case tc_rec:
  308.     cur_exp = args;
  309.     cur_env = env;
  310.     env = envcons(assoc_args_env(cons(proc,args),car(CODE(proc)),env),
  311.         DEFENV(proc));
  312.     args = cdr(CODE(proc));
  313.     return(leval(args,env));
  314.   default:
  315.     cur_exp = args;
  316.     cur_env = env;
  317.     err("attempt to call a non procedural object",proc,ERR_GEN);}}
  318.  
  319. LISP leval_args(LISP l,LISP env)
  320. {LISP result,v1,v2,tmp;
  321.  if NULLP(l) return(NIL);
  322.  result = cons(leval(car(l),env),NIL);
  323.  for(v1=result,v2=cdr(l);
  324.      CONSP(v2);
  325.      v1 = tmp, v2 = CDR(v2))
  326.   {tmp = cons(leval(CAR(v2),env),NIL);
  327.    CDR(v1) = tmp;}
  328.  if NNULLP(v2) err("bad syntax argument list",l,ERR_GEN);
  329.  return(result);}
  330.  
  331. LISP leval_args_env(LISP actuals,LISP formals,LISP env)
  332. {LISP fl,al,result;
  333.  result = NIL;
  334.  for(fl = formals,al = actuals; 
  335.      CONSP(fl)&&CONSP(al); 
  336.      fl = CDR(fl),al = CDR(al))
  337.     result = cons(cons(CAR(fl),
  338.                        leval(CAR(al),env)),
  339.                   result);
  340.  if NULLP(fl)
  341.     {if NNULLP(al)
  342.        err("wrong number of arguments",actuals,ERR_GEN);}
  343.  else if CONSP(fl)
  344.     err("wrong number of arguments",actuals,ERR_GEN);
  345.  else 
  346.    result = cons(cons(fl,leval_args(al,env)),result);
  347.  return(result);}
  348.  
  349. LISP assoc_args_env(LISP actuals,LISP formals,LISP env)
  350. {LISP fl,al,result;
  351.  result = NIL;
  352.  for(fl = formals,al = actuals; 
  353.      CONSP(fl)&&CONSP(al); 
  354.      fl = CDR(fl),al = CDR(al))
  355.     result = cons(cons(CAR(fl),
  356.                        CAR(al)),
  357.                   result);
  358.  if NULLP(fl)
  359.     {if NNULLP(al)
  360.        err("wrong number of arguments",actuals,ERR_GEN);}
  361.  else if CONSP(fl)
  362.     err("wrong number of arguments",actuals,ERR_GEN);
  363.  else 
  364.    result = cons(cons(fl,al),result);
  365.  return(result);}
  366.  
  367.